home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d12 / v10n18.arc / POPDEM.ARC / POPDEM.PRG < prev   
Text File  |  1991-10-30  |  15KB  |  490 lines
  1. ***********************************************************************
  2. * POPDEM.PRG                                             Clipper 5.01
  3. * Demonstrate usage of PopCal for Clipper
  4. ***********************************************************************
  5. SET ECHO OFF
  6. SET TALK OFF
  7. SETBLINK(.F.)
  8. oldcolor = SETCOLOR("W+/B")
  9. CLEAR screen
  10. @ 1,1 CLEAR TO 15,78                 && Clear the area
  11. @ 1,1 TO 15,78
  12. oldcolor = SETCOLOR("G+/B")
  13. @ 1,30 SAY "XYZ Travel Agency"
  14. @ 3,4 SAY "Prefix:"
  15. @ 4,4 SAY "  Last:"
  16. @ 5,4 SAY " First:"
  17. @ 6,4 SAY "Middle:"
  18. @ 7,4 SAY "Suffix:"
  19. @ 9,3 SAY "Address:"
  20. @ 10,4 SAY "      :"
  21. @ 11,4 SAY "      :"
  22. @ 12,4 SAY "  City:"
  23. @ 13,4 SAY " State:"
  24. DO Inquiry                           && Sample date field usage with
  25.                                      && pop-up calendar
  26. RELEASE ALL
  27. CLEAR ALL
  28. RETURN
  29.  
  30. ***********************************************************************
  31. * PROCEDURE Inquiry
  32. * Demonstrate use of PopDate, which is called from PopCal
  33. ***********************************************************************
  34. PROCEDURE Inquiry
  35. @ 3, 12 CLEAR TO 13,60               && Clear the area
  36. @ 3, 12 TO 13,60                     && Box the area
  37. @ 3, 32 SAY "Inquiry"
  38. @ 5, 19 SAY "Destination:"
  39. @ 7, 13 SAY "Date of Departure:"
  40. @ 8, 16 SAY "Date of Return:"
  41. @ 10, 16 SAY "Number of days:"
  42. @ 12, 16 SAY "Enter Departure date, press F2 for calendar"
  43. STORE PAD("Hawaii",25) TO m->dest
  44. STORE DATE() TO m->depdate
  45. STORE DATE()+1 TO m->retdate
  46.  
  47. SET KEY -1 TO POPCAL
  48. DO WHILE .T.
  49.    oldcolor = SETCOLOR(",N/W")
  50.    @ 5,32 GET m->dest
  51.    @ 7,32 GET m->depdate ;
  52.    VALID DateCheck(1, m->depdate, m->retdate)
  53.    @ 8,32 GET m->retdate ;
  54.    VALID DateCheck(2, m->depdate, m->retdate)
  55.    READ
  56.    SETCOLOR(oldcolor)
  57.    @ 10,32 SAY (m->retdate - m->depdate)+1 PICTURE [999]
  58.    IF READKEY()==268 .OR. READKEY()==12   && Escape cancels
  59.       EXIT
  60.    ENDIF
  61. ENDDO
  62.  
  63. SET KEY -1 TO                        && Restore F2
  64. RETURN
  65.  
  66. *******************************************************************
  67. * FUNCTION DateCheck
  68. * Simple validation for departure and return dates
  69. *******************************************************************
  70. FUNCTION DateCheck
  71. PARAMETERS dnum, ddate, rdate
  72.  
  73. DO CASE
  74.  CASE dnum == 1                      && Validating the departure date
  75.    *
  76.    * --- Can't be before today or empty
  77.    *
  78.    IF ddate < DATE() .OR. EMPTY(ddate)
  79.       TONE(100,3)
  80.       RETURN .F.
  81.    ENDIF
  82.  CASE dnum == 2                      && Validating the return date
  83.    *
  84.    * --- Can't be before departure date or empty
  85.    *
  86.    IF rdate < ddate .OR. EMPTY(rdate)
  87.       TONE(100,3)
  88.       RETURN .F.
  89.    ENDIF
  90.  OTHERWISE
  91. ENDCASE
  92. RETURN .T.
  93.  
  94. *******************************************************************************
  95. * Program Name...:  POPCAL.PRG
  96. * Description....:  A Routine to pop up a calender for choosing dates
  97. * Author.........:  F. Martin Richardson, Jr.
  98. * Usage..........:  SET KEY <keycode> TO POPCAL
  99. * Notes..........:  As this is meant to be executed with the SET KEY command,
  100. *                   it expects three parameters:
  101. *                   P - Calling Proc. Name
  102. *                   L - Calling Proc. Line No.
  103. *                   V - Current Variable (the only one it uses)
  104. *
  105. * The calendar will only pop up if you are currently editing a DATE typed
  106. * variable.  The default date will be the one currently being edited, or
  107. * the current date if that date is invalid or the variable is empty.
  108. *
  109. *******************************************************************************
  110. PROCEDURE popcal
  111.  
  112. PARAMETERS p, l, v
  113.  
  114. PRIVATE up_arrow, down_arrow, right_arrow, left_arrow, pgup, pgdn
  115. PRIVATE ctrl_pgup, ctrl_pgdn, box2, inp, cdate
  116.  
  117. IF TYPE( v ) <> 'D' && Make sure it is a DATE variable
  118.    RETURN
  119. ENDIF
  120.  
  121. * Keyboard Scan Codes
  122. up_arrow    = 5
  123. down_arrow  = 24
  124. right_arrow = 4
  125. left_arrow  = 19
  126. pgup        = 18
  127. pgdn        = 3
  128. ctrl_pgup   = 31
  129. ctrl_pgdn   = 30
  130. shift_left  = 52
  131. shift_right = 54
  132. shift_up    = 56
  133. shift_down  = 50
  134.  
  135. box2 = '╔═╗║╝═╚║ '
  136.  
  137. * or BOX2 = chr(201) + chr(205) + chr(187) + chr(186) + chr(188) + chr(205)
  138. *    BOX2 = BOX2 + chr(200) + chr(32)
  139.  
  140. * IF !FILE( 'cal.cfg' )
  141.    lcalrow = 0
  142.    lcalcol = 50
  143. *  SAVE ALL LIKE lcal* TO cal.cfg
  144. * ELSE
  145. *  RESTORE FROM cal.cfg ADDITIVE
  146. * ENDIF
  147.  
  148. SET CURSOR OFF
  149.  
  150. * inverse = 'n/w'
  151.  
  152. inverse = 'W+/GR'
  153.  
  154. SAVE SCREEN TO lpopscreen
  155.  
  156. * oldcolor = setcolor( 'w+/rb' )
  157.  
  158. oldcolor = setcolor( 'W+/BG' )
  159.  
  160. trow = 5 + lcalrow
  161. tcol = 2 + lcalcol
  162. IF EMPTY( &v )
  163.    cdate = DATE()
  164. ELSE
  165.    cdate = &v
  166. ENDIF
  167.  
  168. drawcal( lcalrow, lcalcol )
  169.  
  170. DO WHILE .T.
  171.    inp = INKEY(0)
  172.    DO CASE
  173.    CASE inp = 27 .OR. inp = 13
  174.       EXIT
  175.  
  176.    CASE inp = shift_up .AND. lcalrow > 0 && Shift Up-Arrow
  177.       ltempcal = savescreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23 )
  178.       lcalrow = lcalrow - 1
  179.       trow = 5 + lcalrow
  180.       RESTORE SCREEN FROM lpopscreen
  181.       WINDOW( lcalrow, lcalcol, 17, 24, "GR+/B", box2, .T. )
  182.       restscreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23, ltempcal )
  183.  
  184.    CASE inp = shift_left .AND. lcalcol > 1 && Shift Left-Arrow
  185.       ltempcal = savescreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23 )
  186.       lcalcol = lcalcol - 1
  187.       tcol = 2 + lcalcol
  188.       RESTORE SCREEN FROM lpopscreen
  189.       WINDOW( lcalrow, lcalcol, 17, 24, "GR+/B", box2, .T. )
  190.       restscreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23, ltempcal )
  191.  
  192.    CASE inp = shift_down .AND. lcalrow < 8 && Shift Down-Arrow
  193.       ltempcal = savescreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23 )
  194.       lcalrow = lcalrow + 1
  195.       trow = 5 + lcalrow
  196.       RESTORE SCREEN FROM lpopscreen
  197.       WINDOW( lcalrow, lcalcol, 17, 24, "GR+/B", box2, .T. )
  198.       restscreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23, ltempcal )
  199.  
  200.    CASE inp = shift_right .AND. lcalcol < 55 && Shift Right-Arrow
  201.       ltempcal = savescreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23 )
  202.       lcalcol = lcalcol + 1
  203.       tcol = 2 + lcalcol
  204.       RESTORE SCREEN FROM lpopscreen
  205.       WINDOW( lcalrow, lcalcol, 17, 24, "GR+/B", box2, .T. )
  206.       restscreen( lcalrow, lcalcol, lcalrow+16, lcalcol+23, ltempcal )
  207.  
  208.    CASE inp = up_arrow
  209.       restdate( cdate )
  210.       lmonth = MONTH(cdate)
  211.       cdate = cdate - 7
  212.       IF MONTH(cdate) <> lmonth
  213.          showdates( cdate )
  214.       ELSE
  215.          currdate( cdate )
  216.       ENDIF
  217.  
  218.    CASE inp = down_arrow
  219.       restdate( cdate )
  220.       lmonth = MONTH(cdate)
  221.       cdate = cdate + 7
  222.       IF MONTH(cdate) <> lmonth
  223.          showdates( cdate )
  224.       ELSE
  225.          currdate( cdate )
  226.       ENDIF
  227.  
  228.    CASE inp = left_arrow
  229.       restdate( cdate )
  230.       lmonth = MONTH(cdate)
  231.       cdate = cdate - 1
  232.       IF MONTH(cdate) <> lmonth
  233.          showdates( cdate )
  234.       ELSE
  235.          currdate( cdate )
  236.       ENDIF
  237.  
  238.    CASE inp = right_arrow
  239.       restdate( cdate )
  240.       lmonth = MONTH(cdate)
  241.       cdate = cdate + 1
  242.       IF MONTH(cdate) <> lmonth
  243.          showdates( cdate )
  244.       ELSE
  245.          currdate( cdate )
  246.       ENDIF
  247.  
  248.    CASE inp = pgup
  249.       lmonth = MONTH( cdate ) - 1
  250.       IF lmonth < 1
  251.          lmonth = 12
  252.       ENDIF
  253.       cdate = cdate - 30
  254.       DO WHILE lmonth < MONTH(cdate)
  255.          cdate = cdate - 1
  256.       ENDDO
  257.       DO WHILE lmonth > MONTH(cdate)
  258.          cdate = cdate + 1
  259.       ENDDO
  260.       showdates( cdate )
  261.  
  262.    CASE inp = pgdn
  263.       lmonth = MONTH( cdate ) + 1
  264.       IF lmonth > 12
  265.          lmonth = 1
  266.       ENDIF
  267.       cdate = cdate + 30
  268.       DO WHILE lmonth < MONTH(cdate)
  269.          cdate = cdate - 1
  270.       ENDDO
  271.       DO WHILE lmonth > MONTH(cdate)
  272.          cdate = cdate + 1
  273.       ENDDO
  274.       showdates( cdate )
  275.  
  276.    CASE inp = ctrl_pgup
  277.       lday = DAY(cdate)
  278.       cdate = cdate - 365
  279.       IF lday <> DAY(cdate)
  280.          cdate = cdate - 1
  281.       ENDIF
  282.       showdates( cdate )
  283.  
  284.    CASE inp = ctrl_pgdn
  285.       lday = DAY(cdate)
  286.       cdate = cdate + 365
  287.       IF lday <> DAY(cdate)
  288.          cdate = cdate + 1
  289.       ENDIF
  290.       showdates( cdate )
  291.  
  292.    ENDCASE
  293. ENDDO
  294.  
  295. RESTORE SCREEN FROM lpopscreen
  296. IF LASTKEY() <> 27
  297.    &v = cdate
  298.    IF &v <> cdate
  299.       REPLACE &v WITH cdate
  300.    ENDIF
  301. ENDIF
  302. setcolor( oldcolor )
  303. SET CURSOR ON
  304.  
  305. * Store the current Calendar Window screen coordinates
  306. * SAVE ALL LIKE lcal* TO cal.cfg
  307. RETURN
  308.  
  309. *******************************************************************************
  310. * FUNCTION to draw the calendar window on the screen
  311. *******************************************************************************
  312. FUNCTION drawcal
  313. PARAMETERS lcalrow, lcalcol
  314. * WINDOW( lcalrow, lcalcol, 17, 24, setcolor(), box2, .T. )
  315. WINDOW( lcalrow, lcalcol, 17, 24, "GR+/B", box2, .T. )
  316.  
  317. oldcolor = SETCOLOR("R+/B")
  318. @ lcalrow, lcalcol+6 SAY "[CALENDAR]"
  319. SETCOLOR(oldcolor)
  320.  
  321. * @ lcalrow+2, lcalcol SAY '╟──────────────────────╢'
  322. @ lcalrow+2, lcalcol+1 SAY '──────────────────────'
  323.  
  324. @ lcalrow+3, lcalcol+1 SAY ' Su Mo Tu We Th Fr Sa '
  325.  
  326. * @ lcalrow+4, lcalcol SAY '╟──────────────────────╢'
  327. @ lcalrow+4, lcalcol+1 SAY '──────────────────────'
  328.  
  329. showdates( cdate )
  330. RETURN ''
  331.  
  332. *******************************************************************************
  333. * FUNCTION to center a <string> on row <row> between <col1> and <col2>
  334. *
  335. * SYNTAX:  CENTERAT( row, col1, col2, string )
  336. *
  337. * PARAMETERS:  row       Row to center <string> on
  338. *              coll      Leftmost column to center between
  339. *              colr      Rightmost column to center between
  340. *              string    String to center between <coll> and <colr>
  341. *
  342. * RETURNS:  NIL
  343. *
  344. * NOTES:  If the difference between <coll> and <colr> is less than the length
  345. *         of <string>, then the function defaults to printing <string> on
  346. *         row <row> at column <coll>.
  347. *******************************************************************************
  348. FUNCTION centerat
  349. PARAMETERS ROW, coll, colr, string
  350. IF colr-coll <= LEN(string)
  351.    @ ROW, coll SAY string
  352. ELSE
  353.    @ ROW, coll + ((colr-coll) / 2) - (LEN(string)/2) SAY string
  354. ENDIF
  355. RETURN ''
  356.  
  357. *******************************************************************************
  358. * FUNCTION to display the days of the current months within the calendar
  359. *  window
  360. *******************************************************************************
  361. FUNCTION showdates
  362. PARAMETERS cdate
  363. PRIVATE trow, tcol, tdate
  364. @ lcalrow+5, lcalcol+1 CLEAR TO lcalrow+15, lcalcol+22
  365.  
  366. tdate = cdate - (DAY(cdate)-1)
  367. oldcolor = SETCOLOR("BG+/BG")
  368. @ lcalrow+1, lcalcol+1 SAY center_pad( CMONTH(tdate) + ' ' + ALLTRIM(STR(YEAR(tdate))), ' ', 22 )
  369. SETCOLOR(oldcolor)
  370.  
  371. trow = lcalrow+5
  372. tcol = lcalcol+2
  373. DO WHILE MONTH(tdate) = MONTH(cdate)
  374.    @ trow, tcol + (DOW(tdate)-1)*3 SAY DAY(tdate) PICTURE '99'
  375.    tdate = tdate + 1
  376.    IF DOW(tdate) = 1
  377.       trow = trow + 2
  378.    ENDIF
  379. ENDDO
  380. currdate( cdate )
  381. RETURN ''
  382.  
  383. *******************************************************************************
  384. * FUNCTION to highlight the current date
  385. *******************************************************************************
  386. FUNCTION currdate
  387. PARAMETERS cdate
  388. PRIVATE oldcolor
  389. oldcolor = setcolor( inverse )
  390. fday = DOW(cdate - (DAY(cdate)-1))
  391. trow = INT((DAY(cdate)-1)/7+1)
  392. @ (trow + IF( DOW(cdate) < fday, 1, 0)) *2+6 + (lcalrow-3), tcol+(DOW(cdate)-1)*3 SAY DAY(cdate) PICTURE '99'
  393. setcolor( oldcolor )
  394. RETURN ''
  395.  
  396. *******************************************************************************
  397. * FUNCTION to un-highlight a prior current date
  398. *******************************************************************************
  399. FUNCTION restdate
  400. PARAMETERS cdate
  401. fday = DOW(cdate - (DAY(cdate)-1))
  402. trow = INT((DAY(cdate)-1)/7+1)
  403. @ (trow + IF( DOW(cdate) < fday, 1, 0)) *2+6 + (lcalrow-3), tcol+(DOW(cdate)-1)*3 SAY DAY(cdate) PICTURE '99'
  404. RETURN ''
  405.  
  406. ********************************************************************************
  407. * FUNCTION to draw a window on the screen with optional shadow
  408. *
  409. * SYNTAX:  WINDOW( row, col, rows, cols [, colr [, boxtype [, shad]]] )
  410. *
  411. * PARAMETERS:  row       Top left row of window
  412. *              col       Top left column of window
  413. *              rows      Number of rows
  414. *              cols      Number of columns
  415. *              [colr]    Color of border and background     (def=current color)
  416. *              [boxtype] BOX string                         (def=single line)
  417. *              [shad]    .T. for shadow, .F. for no shadow  (def=.F.)
  418. *
  419. * RETURNS:  NIL
  420. *
  421. * NOTES:  You must specify COLR if you specify BOXTYPE and you must specify
  422. *         BOXTYPE if you specify SHAD!
  423. ********************************************************************************
  424. FUNCTION WINDOW
  425. PARAMETERS row,col,rows,cols,colr,boxtype,shadow
  426. PRIVATE temp
  427.  
  428. * Set Defaults
  429. IF pcount() < 5
  430.    colr = setcolor()
  431. ENDIF
  432. IF pcount() < 6
  433.    boxtype = "┌─┐│┘─└│ "
  434. ENDIF
  435. IF pcount() < 7
  436.    SHADOW = .F.
  437. ENDIF
  438.  
  439. temp = setcolor( colr ) && Preserve current colors
  440.  
  441. * Expand line boxes by 1 space for appearance
  442. IF LEFT(boxtype, 1) = '┌' .OR. LEFT(boxtype, 1) = '╔' .OR. LEFT(boxtype, 1) = '╒' .OR. LEFT(boxtype, 1) = '╓'
  443.    offset = 1
  444. ELSE
  445.    offset = 0
  446. ENDIF
  447.  
  448. IF SHADOW
  449.    setcolor( 'n/n' )
  450.    @ ROW+1, COL+2-offset CLEAR TO ROW+rows, COL+cols+2
  451.    setcolor( colr )
  452. ENDIF
  453.  
  454. * Again expand line boxes by 1 space for appearance
  455. IF LEFT(boxtype, 1) = '┌' .OR. LEFT(boxtype, 1) = '╔' .OR. LEFT(boxtype, 1) = '╒' .OR. LEFT(boxtype, 1) = '╓'
  456.    @ ROW, COL-1, ROW+rows-1, COL+cols BOX SPACE(9)
  457. ENDIF
  458.  
  459. @ ROW, COL, ROW+rows-1, COL+cols-1 BOX boxtype
  460.  
  461. SET COLOR TO &temp && Restore old color
  462. RETURN(.T.)
  463.  
  464. ********************************************************************************
  465. * FUNCTION to center <string> with padded <char> to make LEN(<string>) = <num>
  466. *
  467. * SYNTAX:  CENTER_PAD( string, char, len )
  468. *
  469. * PARAMETERS:  string    String to center
  470. *              char      Characters to pad <string> on either side with
  471. *              len       New length for <string>
  472. *
  473. * RETURNS:  <string> centered to length <len>, padded with <char>
  474. *
  475. * NOTES:  If <len> is less than the length of <string>, the function will
  476. *         default to the original <string>.
  477. ********************************************************************************
  478. FUNCTION center_pad
  479. PARAMETERS string, char, num
  480. PRIVATE rside, lside
  481. IF num <= LEN( string )
  482.    RETURN( string )
  483. ENDIF
  484. rside = num - LEN( string )
  485. lside = INT( rside / 2 )
  486. rside = rside - lside
  487. string = REPLICATE( char, lside ) + string + REPLICATE( char, rside )
  488. RETURN( string )
  489. *: EOF: POPUPCAL.PRG
  490.